;;; -*- Mode:LISP; Package:EH; Lowercase:T; Base:10; Readtable:ZL -*-

;;;; Stepping commands.

;; Control-X: Control the trap-on-exit bits of frames.
(defun com-toggle-frame-trap-on-exit (sg ignore &optional ignore)
  "Toggles whether we trap on exit from this frame."
  (let ((trap-p (not (trap-on-exit-p sg *current-frame*))))
    (set-trap-on-exit sg *current-frame* trap-p)
    (terpri)
    (princ (if (trap-on-exit-p sg *current-frame*) "Break" "Do not break"))
    (princ " on exit from this frame.")))

(defun set-trap-on-exit (sg frame trap-p)
  "Set or clear trap on exit from FRAME in SG.  TRAP-P = T means set, else clear."
  (let ((rp (sg-regular-pdl sg)))
    (if (eq (rp-function-word rp frame) #'*catch)
        (setq trap-p nil))
    (setf (si::rp-attention rp frame) 1)
    (setf (rp-trap-on-exit rp frame) (if trap-p 1 0)))
  trap-p)

(defun trap-on-exit-p (sg frame)
  "T if FRAME in SG is set to trap on being exited."
  (not (zerop (rp-trap-on-exit (sg-regular-pdl sg) frame))))

;; Meta-X
(defun com-set-all-frames-trap-on-exit (sg ignore &optional ignore)
  "Makes all outer frames trap on exit."
  (do ((frame *current-frame* (sg-next-active sg frame)))
      ((null frame))
    (set-trap-on-exit sg frame t))
  (format t "~%Break on exit from this frame and all outer active frames."))

;; Control-Meta-X
(defun com-clear-all-frames-trap-on-exit (sg ignore &optional ignore)
  "Clears the trap-on-exit flag for all outer frames."
  (do ((frame *current-frame* (sg-next-open sg frame)))
      ((null frame))
    (set-trap-on-exit sg frame nil))
  (format t "~%Do not break on exit from this frame and all outer frames."))

;; Control-D: Proceed, and trap next function call.
(defun com-proceed-trap-on-call (sg error-object &optional ignore)
  "Proceeds from this error (if that is possible) and traps on the next function call."
  (setf (sg-flags-trap-on-call sg) 1)
  (format t "Trap on next function call. ")
  (com-proceed sg error-object))

;; Meta-D
(defun com-toggle-trap-on-call (sg ignore &optional ignore)
  "Toggle whether to trap on next function call."
  (setf (sg-flags-trap-on-call sg) (logxor 1 (sg-flags-trap-on-call sg)))
  (terpri)
  (princ (if (zerop (sg-flags-trap-on-call sg)) "Do not break" "Break"))
  (princ " on next function call."))

;;;; Commands for single-stepping and setting breakpoints

;; Meta-Shift-s
;>> SHOULD DO SOMETHING WITH ARG (like step n steps, not single-step called function, etc)
(defun com-macro-single-step (sg error-object &optional arg)
  "Single steps macroinstructions.
Should do something useful with an arg, but doesn't. Foo."
  (declare (special error-object) (ignore arg))
  (if (not *error-handler-running*)
      (throw 'exit t))
;>> Gak!
  (cond ((and (send error-object :debugging-condition-p)
              (send error-object :proceed-asking-user :operation-handled-p :no-action))
         (setf (getf (sg-plist sg) 'single-macro-dispatch) t)
         (format t "Single step...")
         (proceed-error-sg :no-action)
         nil)
        (t (format t "Cannot single-step from an error"))))

;; Control-Shift-s
(defun com-set-breakpoint (sg ignore &optional arg)
  "Sets a breakpoint in a compiled function.
With a numeric arg, sets a breakpoint at that pc withing the current function.
Otherwise prompts for a function and pc."
  (let ((function (rp-function-word (sg-regular-pdl sg) *current-frame*))
        pc)
    (if arg (setq pc arg)
      (multiple-value-setq (function pc)
        (get-compiled-function-and-pc function)))
    (let ((loss (multiple-value-list (check-for-bogus-pc function pc))))
      (if (null loss)
          (set-breakpoint function pc t)
        (apply #'format t loss)))))

;; Control-Shift-c
(defun com-clear-breakpoint (sg ignore &optional arg)
  "Clears a brekpoint from a compiled function.
With no argument, prompts for a function and pc.
With an arg of -1, clears all breakpoints from the current function
With any other argument, clears a breakpoint at that pc of the current function"
  (format t " Clear macrocode breakpoint")
  (let ((function (rp-function-word (sg-regular-pdl sg) *current-frame*))
        pc)
    (cond ((eq arg -1)
           (format t "~P from ~S" (length (function-breakpoints function)) function)
           (clear-breakpoint function nil t)
           (return-from com-clear-breakpoint nil))
          (arg
           (format t " at ~D" arg)
           (setq pc arg))
          (t
           (multiple-value-setq (function pc)
             (get-compiled-function-and-pc function))))
    (let ((loss (multiple-value-list (check-for-bogus-pc function pc))))
      (if (null loss)
          (clear-breakpoint function pc t)
        (apply #'format t loss)))))

;; Meta-Shift-c
(defun com-list-breakpoints (ignore ignore &optional arg)
  "Lists all functions which have breakpoints set in them
and the pc's at which they have breakpoints"
  (declare (ignore arg))
  (dolist (f *fefs-with-breakpoints*)
    (let ((breakpoints (function-breakpoints f)))
      (format t "~&Function ~S has ~:[a breakpoint~;breakpoints~] at pc~:*~[~;~'s~] ~{~D~^, ~}"
              (cdr breakpoints) breakpoints))))

;;>>
(defun com-clear-all-breakpoints (ignore ignore &optional arg)
  "Clears all breakpoints from all functions which have them"
  (declare (ignore arg))
  (dolist (f *fefs-with-breakpoints*)
    (clear-breakpoint f nil t)))


(defun check-for-bogus-pc (fef pc)
  (check-type fef compiled-function)
  (let ((name (fef-name fef))
        (lim (fef-limit-pc fef))
        (min (fef-initial-pc fef)))
    (if (not (fixnump pc))
        (values "The pc must be a fixnum!")
      (cond ((< pc min)
             (values
               "A pc of ~D is invalid for function ~S, whose instructions start at pc ~D"
               pc name min))
            ((> pc lim)
             (values
               "A pc of ~D is invalid for function ~S (which has ~D instructions)"
               pc name lim))
            (t
             (do (len
                  (n min))
                 ((> n lim) (values))
               (setq len (fef-instruction-length fef n))
               (cond ((= n pc) (return (values)))
                     ((< n pc (setq n (+ n len)))
                      (return-from check-for-bogus-pc
                        (values
                          "~The pc ~D lies in the middle of a multi-word instruction in ~S
  (the instruction starts at ~D)~"
                          pc name (- n len)))))))))))


(defun get-compiled-function-and-pc (&optional default-function)
  (declare (values function pc))
  (let* ((function-name (and default-function (function-name default-function)))
         (prompt #'(lambda (stream ignore)
                     (format stream "~&Function name~@[, or ~*~C for default (~S)~]: "
                             function-name #/end function-name)))
         function)
    (setq function (with-input-editing (*debug-io*
                                         `((:prompt ,prompt)
                                           (:activation char= #/end)
                                           ;; :full-rubout is too obnoxious
                                           ))
                     (prog ()
                        loop
                           (multiple-value-bind (fn flag)
                               (si:read-or-end *debug-io* nil nil)
                             (if (eq flag ':end)
                                 (setq fn default-function))
                             (unless (compiled-function-p fn)
                               (condition-case (error)
                                   (setq fn (fdefinition fn))
                                 (error (parse-ferror "~A" error)
                                        (go loop)))
                               (unless (compiled-function-p fn)
                                 (parse-ferror "~S is not a compiled function" fn)
                                 (go loop)))
                             (return fn))))
          function-name (function-name function))
    (let ((min (fef-initial-pc function))
          (lim (fef-limit-pc function)))
      (setq prompt #'(lambda (stream ignore)
                       (format stream "~&PC within function (between ~D and ~D): " min lim)))
      (with-input-editing (*debug-io*
                            `((:prompt ,prompt)
;character lossage
                              (:activation memq (#.(char-int #/end) #.(char-int #/newline)))
                              (:no-input-save t)))
        (tagbody
         loop
            (let* ((*read-base* 10.)
                   (pc (si:read-for-top-level *debug-io* nil nil))
                   (loss (multiple-value-list (check-for-bogus-pc function pc))))
              (if (null loss)
                  (return-from get-compiled-function-and-pc (values function pc))
                (apply #'parse-ferror loss)
                (go loop))))))))

;;;; The guts of breakpointing

(defvar *fefs-with-breakpoints* ()
  "List of fef's which contain a breakpoint")

(defun function-breakpoints (function)
  "Returns a list  ((pc original-instruction-code) ...)"
  (cdr (assq 'breakpoints (debugging-info function))))

(defun set-breakpoint (function pc &optional print)
  "Sets a breakpoint at PC in function FUNCTION (which must be a compiled function)
PRINT means to print a message on *DEBUG-IO* saying that the breakpoint has been set.
Returns T if successful."
  (check-type function compiled-function)
  (cond ((not ( (fef-initial-pc function) pc (fef-limit-pc function)))
         (ferror "~D is not a valid pc in ~S" pc function))
        ((not (fef-debugging-info-present-p function))
         (ferror "~S doesn't have a debugging-info slot. You lose" function)))
  (without-interrupts
    (let* ((debugging-info (fef-debugging-info function))
           (breakpoints (assq 'breakpoints debugging-info))
           (default-cons-area background-cons-area)
           (bpt compiler::(lap-word-eval '(misc bpt d-ignore)))
           (function-name (function-name function)))
      (if (and (assq pc (cdr breakpoints))
               (eq (fef-instruction function pc) bpt))
          (when print
            (format *debug-io* "~&Breakpoint already exists at pc ~D in ~S"
                    pc function-name))
        (let ((inst (fef-instruction function pc)))
          (let ((%inhibit-read-only t))
            (if breakpoints
                (push (list pc inst) (cdr breakpoints))
              (push `(breakpoints . ((,pc ,inst)))
                    (fef-debugging-info function)))
            (setf (fef-instruction function pc) bpt)))
        (pushnew function *fefs-with-breakpoints* :test #'eq)
        (when print
          (format *debug-io* "~&Breakpoint set at pc ~D in ~S" pc function-name))
        t))))

(defun clear-breakpoint (function &optional pc print)
  "Clears a breakpoint at PC in function FUNCTION (which must be a compiled function)
If PC is not supplied, then clears all breakpoints in FUNCTION
PRINT means to print a message in *DEBUG-IO* saying that the breakpoint has been cleared."
  (check-type function compiled-function)
  (without-interrupts
    (let* ((debugging-info (and (fef-debugging-info-present-p function)
                                (fef-debugging-info function)))
           (breakpoints (assq 'breakpoints debugging-info))
           (bpt compiler::(lap-word-eval '(misc bpt d-ignore)))
           (function-name (function-name function)))
      (flet ((do-it (pc &aux (bp (assq pc (cdr breakpoints))))
               (cond ((not ( (fef-initial-pc function) pc (fef-limit-pc function)))
                      (with-stack-list (args "~D is not a valid pc in ~S" pc function)
                        (if print (apply #'format *debug-io* args) (apply #'ferror args)))
                      nil)
                     ((not (eq (fef-instruction function pc) bpt))
                      (with-stack-list (args (if (cdr breakpoints)
                                                 "~&There is no breakpoint in ~S at pc ~D"
                                                 "~&There are no breakpoints set in ~S")
                                             function pc)
                        (if print (apply #'format *debug-io* args) (apply #'ferror args)))
                      nil)
                     ((null bp)
                      (ferror "~There is a breakpoint in ~S at pc ~D.
However, the information necessary to remove it has been lost!
You lose big!!"
                              function pc))
                     (t (let ((%inhibit-read-only t))
                          (setf (fef-instruction function pc) (cadr bp))
                          (setf (cdr breakpoints) (delq bp (cdr breakpoints))))
                        t))))
        (if pc
            (and (do-it pc)
                 print
                 (format *debug-io* "~&Breakpoint cleared at pc ~D in ~S" pc function-name))
          (let ((winners))
            (dolist (c (cdr breakpoints))
              (and (do-it (car c))
                   print
                   (push (car c) winners)))
            (when print
              (if (null winners)
                  (format *debug-io* "~&No breakpoints in ~S" function)
                (format *debug-io* "~&Breakpoint~@[s~] cleared from ~S at pc~@['s~] ~{~D~^ ~}"
                        (eq (length winners) 1) winners)))))
        (if (null breakpoints)
            (setq *fefs-with-breakpoints* (delq function *fefs-with-breakpoints*)))))))


;;;; the real guts of breakpointing

;; the real hard stuff

;; the stuff I haven't written

;>>
;(defmethod (breakpoint-error :case :proceed-asking-user :no-action) ()

;  )

;(defmethod (breakpoint-error :case :proced-asking-user :single-step) ()

;  )

;(defun proceed-breakpoint (sg fef pc single-step-p)
;  (let* ((bpt (assq pc (assq 'breakpoints (fef-debugging-info fef))))
;        (inst (cadr bpt)))
;    (if (null bpt)
;       (ferror "Foo! I don't know about a breakpoint in ~S at ~D. Lossage!!" fef pc)
;      (without-interrupts
;       (let ((%inhibit-read-only t))
;         (swapf (fef-instruction fef pc) inst)))
;      (setf (getf (sg-plist sg) 'single-macro-dispatch) t)
;      (proceed-error-sg :no-action)


;;;; BREAKON

(defvar *breakon-function-specs* ()
  "List of all function-specs that have BREAKONs.")

(defun breakon (&optional function-spec (condition t))
  "Break on entry to FUNCTION-SPEC, if CONDITION evaluates non-NIL.
If called repeatedly for one function-spec with different conditions,
a break will happen if any of the conditions evaluates non-NIL.

With no args, returns a list of function specs that have had
break-on-entry requested with BREAKON."
  (if (null function-spec)
      *breakon-function-specs*
    (setq function-spec (dwimify-arg-package function-spec 'function-spec))
    (breakon-init function-spec)
    (setq condition (si:rename-within-new-definition-maybe function-spec condition))
    (let* ((spec1 (si:unencapsulate-function-spec function-spec 'breakon)))
      (uncompile spec1 t)
      (let* ((def (fdefinition spec1))
             (default-cons-area background-cons-area)
             ;; Find our BREAKON-THIS-TIME.
             ;; def looks like:
             ;;   (named-lambda (foo debugging-info) arglist
             ;;     (si::encapsulation-let ((arglist (si::encapsulation-list* arglist)))
             ;;        (declare (special arglist))
             ;;        (breakon-this-time (or . conditions) unencapsulated-function arglist)))
             (defn-data (car (si::encapsulation-body def)))
             (slot-loc (cadr defn-data)))       ;Within that, find ptr to list of conditions.
        (pushnew condition (cdr slot-loc) :test #'equal)))
    (if compile-encapsulations-flag
        (compile-encapsulations function-spec 'breakon))
    function-spec))

(defun unbreakon (&optional function-spec (condition t))
  "Remove break on entry to FUNCTION-SPEC, or all functions if no arg.
If CONDITION is specified, we remove only that condition for breaking;
if other conditions have been specified with BREAKON on this function,
the other conditions remain in effect."
  (when function-spec
    (setq function-spec (dwimify-arg-package function-spec 'function-spec)))
  (let* ((spec1 (and function-spec (si:unencapsulate-function-spec function-spec 'breakon))))
    (cond ((null function-spec)
           (mapc #'unbreakon *breakon-function-specs*))
          ((eq condition t)
           (fdefine spec1 (fdefinition (si:unencapsulate-function-spec spec1 '(breakon))))
           (setq *breakon-function-specs*
                 (cl:delete function-spec *breakon-function-specs* :test #'equal))
           function-spec)
          ((neq spec1 (si:unencapsulate-function-spec spec1 '(breakon)))
           (uncompile spec1 t)
           (let* ((def (fdefinition spec1))
                  ;; Find our BREAKON-NEXT-TIME.
                  ;; def looks like:
                  ;;   (named-lambda (foo debugging-info) arglist
                  ;;      (si::encapsulation-let ((arglist (si::encapsulation-list* arglist)))
                  ;;        (declare (special arglist))
                  ;;        (breakon-this-time (or . conditions) unencapsulated-function arglist)))
                  (defn-data (car (si::encapsulation-body def)))
                  (slot-loc (cadr defn-data)))  ;Within that, find ptr to list of conditions.
             (setf (cdr slot-loc)
                   (cl:delete condition (cdr slot-loc) :test #'equal))
             (cond ((null (cdr slot-loc))
                    (fdefine spec1
                             (fdefinition (si:unencapsulate-function-spec spec1 '(breakon))))
                    (setq *breakon-function-specs*
                          (cl:delete function-spec *breakon-function-specs* :test #'equal)))
                   (compile-encapsulations-flag
                    (compile-encapsulations function-spec 'breakon))))
           function-spec))))

;;; Make a specifed function into an broken-on function
;;; (with no conditions yet) if it isn't one already.
(defun breakon-init (function-spec)
  (let ((default-cons-area background-cons-area)
        (spec1 (si:unencapsulate-function-spec function-spec 'breakon)))
    (when (eq spec1 (si:unencapsulate-function-spec spec1 '(breakon)))
      (si:encapsulate spec1 function-spec 'breakon
                      ;; Must cons the (OR) afresh -- it gets RPLAC'd.
                      `(breakon-this-time ,(list 'or)
                                          ,si::encapsulated-function
                                          arglist)
                      '((uninteresting-function debug)))
      (push function-spec *breakon-function-specs*))))

(defun breakon-this-time (break-condition function args)
  (declare (uninteresting-function debug))
  (when break-condition
    (select-processor
      (:cadr (setf (ldb %%m-flags-trap-on-call %mode-flags) 1))
      ((:lambda :explorer) (compiler::%trap-on-next-call))))
  ;; The next call ought to be the function the user is trying to call.
  ;; That will be so only if this function is compiled.
  (apply function args))
